home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Src / trace.c < prev    next >
Encoding:
C/C++ Source or Header  |  1996-07-21  |  8.1 KB  |  277 lines
  1. /*
  2.  *
  3.  * t r a c e . c                 -- Variable Tracing
  4.  * 
  5.  * Variable tracing is important in Tk since some widgets intensively use this
  6.  * mechanism. For instance, a check-button has a variable associated to it.
  7.  * When the button is clicked, the variable is set and when the variable is 
  8.  * modified, button state is consequntly changed (last case is done with a trace
  9.  * over the associated variable). Tcl trace mechanism is more general than this;
  10.  * the mechanism implemented here is just intended to mimic the trace over 
  11.  * variable writing (reading a var is not used by Tk and procedure tracing is a
  12.  * common thing easy to do in the Lisp world).
  13.  * Note: a single variable can be associated to several C functions (For instance
  14.  * when a radio-button associated variable is changed, a C function is used to 
  15.  * clear the selector and another to hilight the new selector). So, traces are 
  16.  * stored in a linked list (all traces are called on variable changement).
  17.  *
  18.  * Note:
  19.  *    - Implementation use Tcl hash tables to see if a variable is traced.
  20.  *
  21.  * Copyright ⌐ 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  22.  * 
  23.  *
  24.  * Permission to use, copy, and/or distribute this software and its
  25.  * documentation for any purpose and without fee is hereby granted, provided
  26.  * that both the above copyright notice and this permission notice appear in
  27.  * all copies and derived works.  Fees for distribution or use of this
  28.  * software or derived works may only be charged with express written
  29.  * permission of the copyright holder.  
  30.  * This software is provided ``as is'' without express or implied warranty.
  31.  *
  32.  * This software is a derivative work of other copyrighted softwares; the
  33.  * copyright notices of these softwares are placed in the file COPYRIGHTS
  34.  *
  35.  *
  36.  *           Author: Erick Gallesio [eg@unice.fr]
  37.  *    Creation date: 24-Feb-1993 13:07
  38.  * Last file update: 21-Jul-1996 21:29
  39.  *
  40.  */
  41.  
  42. #include "stk.h"
  43.  
  44.  
  45. #define TRACING     (1<<20)
  46. #define STk_TRACE     TCL_TRACE_READS /* We use TCL_TRACE_READS, which is     */
  47.                     /* not used by Tk, for tagging        */
  48.                     /* traces set with the trace-var     */
  49.                     /* procedure                 */
  50.  
  51. typedef struct STk_VarTrace {
  52.   Tcl_VarTraceProc *traceProc; /* Procedure to call when operations given
  53.                 * by flags are performed on variable. */
  54.   ClientData clientData;       /* Argument to pass to proc. */
  55.   int flags;               /* What events the trace procedure is
  56.                 * interested in:  OR-ed combination of
  57.                 * TCL_TRACE_READS, TCL_TRACE_WRITES, and
  58.                 * TCL_TRACE_UNSETS. */
  59.   struct STk_VarTrace *nextPtr;/* Next in list of traces associated with
  60.                 * a particular variable. */
  61.   SCM env;               /* Environment of this variable */
  62. } STk_var_trace;
  63.  
  64. static Tcl_HashTable VarTable;    /* Global hash table retaining traced variables */
  65.  
  66. /******************************************************************************
  67.  *
  68.  * Scheme part
  69.  *
  70.  ******************************************************************************/
  71. /********** L O W   L E V E L **********/
  72.  
  73. static int TraceVar(SCM var, int flags, Tcl_VarTraceProc *proc, 
  74.             ClientData clientData, SCM env)
  75. {
  76.   int         new;
  77.   Tcl_HashEntry    *entry;
  78.   STk_var_trace    *data;
  79.   
  80.   entry = Tcl_CreateHashEntry(&VarTable, PNAME(var), &new);
  81.   /* Create the value associated to the "var" key */
  82.   data= (STk_var_trace *) ckalloc((unsigned) sizeof (STk_var_trace));
  83.   data->flags       = flags  & ~TCL_TRACE_UNSETS; /* Unset has no meaning in stk */;
  84.   data->traceProc  = proc;
  85.   data->clientData = clientData;
  86.   data->env       = env;
  87.   data->nextPtr       = (STk_var_trace *) (new ? NULL : Tcl_GetHashValue(entry));
  88.  
  89.   /* Put it in table */
  90.   Tcl_SetHashValue(entry, (ClientData) data);
  91.  
  92.   /* Retain that it exist a traced variable for this symbol */
  93.   var->cell_info |= CELL_INFO_TRACED_VAR;
  94.  
  95.   return TCL_OK;
  96. }
  97.  
  98.  
  99. static void UntraceVar(SCM var, int flags, Tcl_VarTraceProc *proc,
  100.                ClientData clientData)
  101. {
  102.   Tcl_HashEntry *entry;
  103.   register STk_var_trace *p, *prev;
  104.   
  105.   if (entry = Tcl_FindHashEntry(&VarTable, PNAME(var))) {
  106.     /* Variable is traced. Try to find correponding trace function */
  107.     flags &= ~TCL_TRACE_UNSETS; /* Unset has no meaning for us */
  108.  
  109.     p = (STk_var_trace *) Tcl_GetHashValue(entry);    
  110.     for (prev=NULL; p ; prev=p, p=p->nextPtr) {
  111.       if (p->traceProc == proc && p->flags == flags && p->clientData == clientData)
  112.     break;
  113.     }
  114.     if (p) {
  115.       if (prev == NULL) {
  116.     if (p->nextPtr)
  117.       Tcl_SetHashValue(entry, (ClientData *) p->nextPtr);
  118.     else 
  119.       Tcl_DeleteHashEntry(entry);
  120.       }
  121.       else
  122.     prev->nextPtr = p->nextPtr;
  123.       ckfree(p);
  124.     }
  125.   }
  126. }
  127.  
  128.  
  129. static char *TraceVarFct(ClientData clientData, Tcl_Interp *interp, 
  130.              char *name1, char *name2, int flags)
  131. {
  132.   /* 
  133.    * ClientData is the only field which of interest here. It contains the
  134.    * thunk to call
  135.    */
  136.   STk_apply((SCM) clientData, NIL);
  137.  
  138.   return NULL; /* to make the compiler happy */
  139. }
  140.  
  141.  
  142. /*
  143.  * STk_complete_untrace
  144.  *
  145.  * Delete all the traces associated to a variable (used by ``untrace-var'')
  146.  *
  147.  */
  148.  
  149. static void complete_untrace(char *var)
  150. {
  151.   Tcl_HashEntry *entry;
  152.   register STk_var_trace *p, *q;
  153.   
  154.   if (entry = Tcl_FindHashEntry(&VarTable, var)) {
  155.     /* Variable is traced. Try to find correponding trace function */
  156.     for (p = (struct STk_VarTrace *) Tcl_GetHashValue(entry); p; p=q) {
  157.       q = p=p->nextPtr;
  158.       ckfree(p);
  159.     }
  160.     Tcl_DeleteHashEntry(entry);
  161.   }
  162. }
  163.  
  164. /*
  165.  * STk_change_value
  166.  *
  167.  * This function is called by Scheme when a there's a change on a traced global
  168.  * variable (using a set! or a define). 
  169.  *
  170.  */
  171.  
  172. void STk_change_value(SCM var, SCM env)
  173. { 
  174.   Tcl_HashEntry *entry;
  175.   register STk_var_trace *data, *p;
  176.  
  177.   if (entry = Tcl_FindHashEntry(&VarTable, PNAME(var))) {
  178.     /* Variable is traced. Call all the associated traces */
  179.     data = (STk_var_trace *) Tcl_GetHashValue(entry);
  180.     
  181.     for (p = data; p ; p = p->nextPtr) {
  182.       /* Invoke trace procedure if not already active */
  183.       if (p->flags & TRACING) 
  184.     continue;
  185.  
  186.       p->flags |= TRACING;
  187. #ifdef USE_TK
  188.       (*p->traceProc)(p->clientData, STk_main_interp, PNAME(var), "", p->flags);
  189. #else
  190.       (*p->traceProc)(p->clientData, NULL, PNAME(var), "", p->flags);
  191. #endif
  192.       /* Unset our flag */
  193.       p->flags &= ~TRACING;
  194.     }
  195.   }
  196. }
  197.  
  198. void STk_mark_tracevar_table(void)
  199. {
  200.   Tcl_HashEntry     *ent;
  201.   Tcl_HashSearch    tmp;
  202.   register STk_var_trace *p;
  203.  
  204.   for (ent=Tcl_FirstHashEntry(&VarTable, &tmp); ent;  ent=Tcl_NextHashEntry(&tmp)) {
  205.     for (p = (STk_var_trace *) Tcl_GetHashValue(ent); p; p=p->nextPtr) {
  206.       if (p->flags & STk_TRACE) 
  207.     /* This is a trace done in Scheme (with trace-var). Consequently,
  208.      * clientData is a closure that we must mark */
  209.     STk_gc_mark((SCM)(p->clientData));
  210.     }
  211.   }
  212. }
  213.  
  214.  
  215. /********** U S E R   I N T E R F A C E **********/
  216.  
  217. PRIMITIVE STk_trace_var(SCM var, SCM code)
  218. {
  219.   if (NSYMBOLP(var))        Err("trace-var: bad variable name", var);
  220.   if (!STk_is_thunk(code)) Err("trace-var: bad thunk", var);
  221.   
  222.   /* Add the trace */
  223.   TraceVar(var, TCL_TRACE_WRITES|STk_TRACE, TraceVarFct, (ClientData) code, NIL);
  224.   return UNDEFINED;
  225. }
  226.  
  227. PRIMITIVE STk_untrace_var(SCM var)
  228. {
  229.   if (NSYMBOLP(var)) Err("untrace-var: bad variable name", var);
  230.   complete_untrace(PNAME(var));
  231.  
  232.   return UNDEFINED;
  233. }
  234.  
  235.  
  236.  
  237. #ifdef USE_TK
  238. /*
  239.  *
  240.  * Tcl Part
  241.  *
  242.  */
  243.  
  244. int Tcl_TraceVar(interp, var, flags, proc, clientData)
  245.      Tcl_Interp *interp; char *var; int flags;
  246.      Tcl_VarTraceProc *proc; ClientData clientData;
  247. {
  248.   return TraceVar(Intern(var), flags, proc, clientData, NIL);
  249. }
  250.  
  251. int Tcl_TraceVar2(interp, name1, name2, flags, proc, clientData)
  252.      Tcl_Interp *interp; char *name1, *name2; int flags; 
  253.      Tcl_VarTraceProc *proc; ClientData clientData;
  254. {
  255.   return TraceVar(Intern(name1), flags, proc, clientData, NIL);
  256. }
  257.  
  258. void Tcl_UntraceVar(interp, var, flags, proc, clientData)
  259.      Tcl_Interp *interp; char *var; int flags;
  260.      Tcl_VarTraceProc *proc; ClientData clientData;
  261. {
  262.   UntraceVar(Intern(var), flags, proc, clientData);
  263. }
  264.  
  265. void Tcl_UntraceVar2(interp, name1, name2, flags, proc, clientData)
  266.      Tcl_Interp *interp; char *name1, *name2; int flags; 
  267.      Tcl_VarTraceProc *proc; ClientData clientData;
  268. {
  269.   UntraceVar(Intern(name1), flags, proc, clientData);
  270. }
  271. #endif
  272.  
  273. void STk_init_tracevar(void)
  274. {
  275.   Tcl_InitHashTable(&VarTable, TCL_ONE_WORD_KEYS);
  276. }
  277.